home *** CD-ROM | disk | FTP | other *** search
/ BBS in a Box 3 / BBS in a box - Trilogy III.iso / Files / Prog / L-M / MacOberon 4.0 / MacOberon™ 4.0 Folder / SortDemo.Mod (.txt) < prev    next >
Encoding:
Oberon Text  |  1993-10-25  |  12.7 KB  |  381 lines  |  [.Ob./.Ob5]
  1. Syntax10.Scn.Fnt
  2. Syntax10i.Scn.Fnt
  3. Syntax12i.Scn.Fnt
  4. Syntax10b.Scn.Fnt
  5. MODULE SortDemo;    (* Wolfgang Weck, 21.1.93, SmoothSort due to E.W.Dijkstra, J.Gutknecht / mf 25.10.93 *)
  6.     A Demonstration of Several Standard Sorting Algorithms
  7.     Position the Star Marker in this viewer (Enter on Keypad)
  8.             Compiler.Compile *
  9.     A Tool Text has been prepared for using this Demo program:
  10.             Edit.Open SortDemo.Tool
  11.     IMPORT
  12.         Oberon, MenuViewers, Viewers, TextFrames, Texts, Display, Input;
  13.     CONST
  14.         N=150;    (* number of elements *)
  15.         Size=1;    (* scale of display *)
  16.         delay=0;    (* increase to slow animation *)
  17.         MinLeft=20; PerSec=300;
  18.         Menu="System.Close  System.Grow ";
  19.     TYPE
  20.         Data=POINTER TO DataDesc;
  21.         DataDesc=RECORD
  22.             list, lastRandom: ARRAY N OF INTEGER
  23.         END;
  24.         Frame=POINTER TO FrameDesc;
  25.         FrameDesc=RECORD
  26.             (Display.FrameDesc)
  27.             data: Data
  28.         END;
  29.         ReorderMsg=RECORD(Display.FrameMsg)
  30.             data: Data
  31.         END;
  32.         SwapMsg=RECORD
  33.             (Display.FrameMsg)
  34.             data: Data;
  35.             i, j: INTEGER
  36.         END;
  37.         seed, comparisons, swaps, time: LONGINT;
  38.         w: Texts.Writer;
  39. (* Frames *)
  40.     PROCEDURE ReplConst(f: Display.FrameDesc; col, x, y, w, h, mode: INTEGER);
  41.         VAR a: INTEGER;
  42.     BEGIN
  43.         a:=f.X-x; IF a > 0 THEN x:=f.X; w:=w-a END;
  44.         a:=f.X+f.W-x; IF a < w THEN w:=a END;
  45.         a:=f.Y-y; IF a > 0 THEN y:=f.Y; h:=h-a END;
  46.         a:=f.Y+f.H-y; IF a < h THEN h:=a END;
  47.         IF (w > 0) & (h > 0) THEN Display.ReplConst(col, x, y, w, h, mode) END
  48.     END ReplConst;
  49.     PROCEDURE UpdateReorder(f: Frame);
  50.         VAR left, x0, y0, i: INTEGER; data: Data;
  51.     BEGIN Oberon.RemoveMarks(f.X, f.Y, f.W, f.H); left:=(f.W-N*Size-2) DIV 2;
  52.         IF left < MinLeft THEN left:=MinLeft END;
  53.         x0:=f.X+left; y0:=f.Y+f.H-MinLeft-N*Size+1;
  54.         ReplConst(f^, Display.black, x0, y0, N*Size, N*Size, Display.replace);
  55.         i:=N; data:=f.data;
  56.         REPEAT DEC(i);
  57.             ReplConst(f^, Display.white, x0+i*Size, y0+data.list[i]*Size, Size, Size, Display.replace)
  58.         UNTIL i=0
  59.     END UpdateReorder;
  60.     PROCEDURE UpdateSwap(f: Frame; i, j: INTEGER);
  61.         VAR left, x0, y0, xi, yi, xj, yj: INTEGER;
  62.     BEGIN Oberon.RemoveMarks(f.X, f.Y, f.W, f.H); left:=(f.W-N*Size-2) DIV 2;
  63.         IF left < MinLeft THEN left:=MinLeft END;
  64.         x0:=f.X+left; y0:=f.Y+f.H-MinLeft-N*Size+1;
  65.         xi:=x0+i*Size; yi:=y0+f.data.list[i]*Size;
  66.         xj:=x0+j*Size; yj:=y0+f.data.list[j]*Size;
  67.         ReplConst(f^, Display.white, xi, yj, Size, Size, Display.invert);
  68.         ReplConst(f^, Display.white, xj, yi, Size, Size, Display.invert);
  69.         ReplConst(f^, Display.white, xi, yi, Size, Size, Display.invert);
  70.         ReplConst(f^, Display.white, xj, yj, Size, Size, Display.invert)
  71.     END UpdateSwap;
  72.     PROCEDURE Modify(f: Frame; id, dy, y, h: INTEGER);
  73.         VAR x0, y0, i, left: INTEGER; data: Data; clipFrame: Display.FrameDesc;
  74.     BEGIN
  75.         IF id=MenuViewers.reduce THEN
  76.             IF dy#0 THEN Display.CopyBlock(f.X, f.Y+dy, f.W, h, f.X, y, Display.replace) END;
  77.             f.Y:=y; f.H:=h
  78.         ELSE
  79.             IF dy#0 THEN Display.CopyBlock(f.X, f.Y, f.W, f.H, f.X, f.Y+dy, Display.replace) END;
  80.             clipFrame.X:=f.X; clipFrame.W:=f.W; clipFrame.Y:=y; clipFrame.H:=h-f.H;
  81.             f.Y:=y; f.H:=h; left:=(f.W-N*Size-2) DIV 2;
  82.             IF left < MinLeft THEN left:=MinLeft END;
  83.             x0:=f.X+left; y0:=f.Y+f.H-MinLeft-N*Size+1;
  84.             ReplConst(clipFrame, Display.black, f.X, f.Y, f.W, f.H, Display.replace);
  85.             ReplConst(clipFrame, Display.white, x0-1, y0-1, N*Size+2, 1, Display.replace);
  86.             ReplConst(clipFrame, Display.white, x0-1, y0+N*Size, N*Size+2, 1, Display.replace);
  87.             ReplConst(clipFrame, Display.white, x0-1, y0, 1, N*Size+1, Display.replace);
  88.             ReplConst(clipFrame, Display.white, x0+N*Size, y0, 1, N*Size+1, Display.replace);
  89.             i:=N; data:=f.data;
  90.             REPEAT DEC(i);
  91.                 ReplConst(clipFrame, Display.white, x0+i*Size, y0+data.list[i]*Size, Size, Size, Display.replace)
  92.             UNTIL i=0
  93.         END
  94.     END Modify;
  95.     PROCEDURE CopyOf(f: Frame): Frame;
  96.         VAR c: Frame;
  97.     BEGIN NEW(c); c.handle:=f.handle; c.data:=f.data; RETURN c
  98.     END CopyOf;
  99.     PROCEDURE* Handler(f: Display.Frame; VAR m: Display.FrameMsg);
  100.         VAR self: Frame;
  101.     BEGIN self:=f(Frame);
  102.         IF m IS ReorderMsg THEN
  103.             IF m(ReorderMsg).data=self.data THEN UpdateReorder(self) END
  104.         ELSIF m IS SwapMsg THEN
  105.             WITH m: SwapMsg DO
  106.                 IF m.data=self.data THEN UpdateSwap(self, m.i, m.j) END
  107.             END
  108.         ELSIF m IS MenuViewers.ModifyMsg THEN
  109.             WITH m: MenuViewers.ModifyMsg DO Modify(self, m.id, m.dY, m.Y, m.H) END
  110.         ELSIF m IS Oberon.CopyMsg THEN m(Oberon.CopyMsg).F:=CopyOf(self)
  111.         ELSIF m IS Oberon.InputMsg THEN
  112.             WITH m: Oberon.InputMsg DO
  113.                 IF m.id=Oberon.track THEN Oberon.DrawCursor(Oberon.Mouse, Oberon.Arrow, m.X, m.Y) END
  114.             END
  115.         END
  116.     END Handler;
  117. (* Data manipulations *)
  118.     PROCEDURE Less(data: Data; i, j: INTEGER): BOOLEAN;
  119.         VAR x, y: INTEGER; keys: SET;
  120.     BEGIN x:=delay;
  121.         WHILE x#0 DO DEC(x); y:=100;
  122.             REPEAT DEC(y) UNTIL y=0
  123.         END;
  124.         IF comparisons MOD 16=0 THEN
  125.             REPEAT Input.Mouse(keys, x, y) UNTIL keys={}
  126.         END;
  127.         INC(comparisons);
  128.         RETURN data.list[i] < data.list[j]
  129.     END Less;
  130.     PROCEDURE Swap(data: Data; i, j: INTEGER);
  131.         VAR x: INTEGER; msg: SwapMsg;
  132.     BEGIN x:=data.list[i]; data.list[i]:=data.list[j]; data.list[j]:=x;
  133.         INC(swaps);
  134.         msg.data:=data; msg.i:=i; msg.j:=j; Viewers.Broadcast(msg);
  135.     END Swap;
  136. (* auxiliary *)
  137.     PROCEDURE ParameterData(): Data;
  138.         VAR l: Data; v: Viewers.Viewer;
  139.     BEGIN
  140.         IF Oberon.Par.vwr.dsc=Oberon.Par.frame THEN
  141.             IF (Oberon.Par.frame#NIL) & (Oberon.Par.frame.next#NIL) & (Oberon.Par.frame.next IS Frame) THEN
  142.                 l:=Oberon.Par.frame.next(Frame).data
  143.             END
  144.         ELSE v:=Oberon.MarkedViewer();
  145.             IF (v.dsc#NIL) & (v.dsc.next#NIL) & (v.dsc.next IS Frame) THEN l:=v.dsc.next(Frame).data END
  146.         END;
  147.         RETURN l
  148.     END ParameterData;
  149.     PROCEDURE Start;
  150.     BEGIN comparisons:=0; swaps:=0; time:=Oberon.Time()
  151.     END Start;
  152.     PROCEDURE Stop(name: ARRAY OF CHAR);
  153.         VAR t: LONGINT;
  154.     BEGIN t:=Oberon.Time();
  155.         Texts.WriteString(w, name); Texts.WriteString(w, ": ");
  156.         Texts.WriteInt(w, comparisons, 0); Texts.WriteString(w, " comparisons, ");
  157.         Texts.WriteInt(w, swaps , 0); Texts.WriteString(w, " swaps, ");
  158.         t:=(t-time)*100 DIV PerSec;
  159.         Texts.WriteInt(w, t DIV 100, 0); Texts.Write(w, "."); Texts.WriteInt(w, t DIV 10 MOD 10, 0);
  160.         Texts.WriteInt(w, t MOD 10, 0); Texts.WriteString(w, " sec");
  161.         Texts.WriteLn(w); Texts.Append(Oberon.Log, w.buf)
  162.     END Stop;
  163. (* commands *)
  164.     PROCEDURE Open*;
  165.         VAR x, y, i: INTEGER; data: Data; f: Frame; v: MenuViewers.Viewer;
  166.     BEGIN NEW(data); i:=N;
  167.         REPEAT DEC(i); data.list[i]:=i UNTIL i=0;
  168.         data.lastRandom:=data.list;
  169.         NEW(f); f.handle:=Handler; f.data:=data;
  170.         Oberon.AllocateUserViewer(Oberon.Mouse.X, x, y);
  171.         v:=MenuViewers.New(TextFrames.NewMenu("SortDemo", Menu), f, TextFrames.menuH, x, y)
  172.     END Open;
  173. (* pre ordering *)
  174.     PROCEDURE Randomize*;
  175.         CONST a=16807; m=2147483647; q=m DIV a; r=m MOD a;
  176.         VAR i, n: LONGINT; k, l, x: INTEGER; data: Data; msg: ReorderMsg;
  177.     BEGIN data:=ParameterData();
  178.         IF data#NIL THEN n:=N DIV 4;
  179.             REPEAT DEC(n); i:=a*(seed MOD q)-r*(seed DIV q);
  180.                 IF i > 0 THEN seed:=i ELSE seed:=i+m END;
  181.                 k:=SHORT(seed MOD N); l:=SHORT((seed DIV N) MOD N);
  182.                 x:=data.list[k]; data.list[k]:=data.list[l]; data.list[l]:=x;
  183.             UNTIL n=0;
  184.             data.lastRandom:=data.list;
  185.             msg.data:=data; Viewers.Broadcast(msg)
  186.         END
  187.     END Randomize;
  188.     PROCEDURE Recall*;
  189.         VAR data: Data; msg: ReorderMsg;
  190.     BEGIN data:=ParameterData();
  191.         IF data#NIL THEN data.list:=data.lastRandom; msg.data:=data; Viewers.Broadcast(msg) END
  192.     END Recall;
  193.     PROCEDURE ReverseOrder*;
  194.         VAR i: INTEGER; data: Data; msg: ReorderMsg;
  195.     BEGIN data:=ParameterData();
  196.         IF data#NIL THEN i:=N;
  197.             REPEAT DEC(i); data.list[i]:=N-1-i UNTIL i=0;
  198.             msg.data:=data; Viewers.Broadcast(msg)
  199.         END
  200.     END ReverseOrder;
  201.     PROCEDURE QuickWorstOrder*;
  202.         VAR i, j, m, x: INTEGER; data: Data; msg: ReorderMsg;
  203.     BEGIN data:=ParameterData();
  204.         IF data#NIL THEN i:=N;
  205.             REPEAT DEC(i); data.list[i]:=i UNTIL i=0;
  206.             i:=(N-1) DIV 2; j:=i;
  207.             WHILE j < N-1 DO INC(j); m:=(i+j) DIV 2; x:=data.list[j]; data.list[j]:=data.list[m]; data.list[m]:=x;
  208.                 IF i > 0 THEN DEC(i); m:=(i+j) DIV 2; x:=data.list[i]; data.list[i]:=data.list[m]; data.list[m]:=x END
  209.             END;
  210.             msg.data:=data; Viewers.Broadcast(msg)
  211.         END
  212.     END QuickWorstOrder;
  213. (* sorters *)
  214.     PROCEDURE Bubble*;
  215.         VAR swapped: BOOLEAN; i, n: INTEGER; data: Data;
  216.     BEGIN data:=ParameterData();
  217.         IF data#NIL THEN Start; n:=N;
  218.              REPEAT swapped:=FALSE; i:=1;
  219.                  WHILE i < n DO
  220.                      IF Less(data, i, i-1) THEN Swap(data, i, i-1); swapped:=TRUE END;
  221.                      INC(i)
  222.                  END
  223.              UNTIL ~swapped;
  224.             Stop("SortDemo.Bubble")
  225.         END
  226.     END Bubble;
  227.     PROCEDURE MinSearch*;
  228.         VAR i, j, min: INTEGER; data: Data;
  229.     BEGIN data:=ParameterData();
  230.         IF data#NIL THEN Start; i:=0;
  231.             WHILE i < N DO min:=i; j:=i+1;
  232.                 WHILE j < N DO
  233.                     IF Less(data, j, min) THEN min:=j END;
  234.                     INC(j)
  235.                 END;
  236.                 IF i#min THEN Swap(data, i, min) END;
  237.                 INC(i)
  238.             END;
  239.             Stop("SortDemo.MinSearch")
  240.         END
  241.     END MinSearch;
  242.     PROCEDURE Insert*;
  243.         VAR i, lo, hi, m: INTEGER; data: Data;
  244.     BEGIN data:=ParameterData();
  245.         IF data#NIL THEN Start; i:=1;
  246.             WHILE i < N DO lo:=0; hi:=i;
  247.                 WHILE lo#hi DO m:=(lo+hi) DIV 2;
  248.                     IF ~Less(data, i, m) THEN lo:=m+1 ELSE hi:=m END
  249.                 END;
  250.                 m:=i;
  251.                 WHILE m > hi DO Swap(data, m-1, m); DEC(m) END;
  252.                 INC(i)
  253.             END;
  254.             Stop("SortDemo.Insert")
  255.         END
  256.     END Insert;
  257.     PROCEDURE Shell*;
  258.         VAR i, j, h: INTEGER; data: Data;
  259.     BEGIN data:=ParameterData();
  260.         IF data#NIL THEN Start; i:=4; h:=1;
  261.             WHILE i < N DO i:=i*2; h:=2*h+1 END;
  262.             WHILE h#0 DO i:=h;
  263.                 WHILE i < N DO j:=i-h;
  264.                     WHILE (j >= 0) & Less(data, j+h, j) DO Swap(data, j, j+h); j:=j-h END;
  265.                     INC(i)
  266.                 END;
  267.                 h:=(h-1) DIV 2
  268.             END;
  269.             Stop("SortDemo.Shell")
  270.         END
  271.     END Shell;
  272.     PROCEDURE Quick*;
  273.         VAR data: Data;
  274.         PROCEDURE Sort(lo, hi: INTEGER);
  275.             VAR i, j, m: INTEGER;
  276.         BEGIN
  277.             IF lo < hi THEN i:=lo; j:=hi; m:=(lo+hi) DIV 2;
  278.                 REPEAT
  279.                     WHILE Less(data, i, m) DO INC(i) END;
  280.                     WHILE Less(data, m, j) DO DEC(j) END;
  281.                     IF i <= j THEN
  282.                         IF m=i THEN m:=j ELSIF m=j THEN m:=i END;
  283.                         Swap(data, i, j); INC(i); DEC(j)
  284.                     END
  285.                 UNTIL i > j;
  286.                 Sort(lo, j); Sort(i, hi)
  287.             END
  288.         END Sort;
  289.     BEGIN data:=ParameterData();
  290.         IF data#NIL THEN Start; Sort(0, N-1); Stop("SortDemo.Quick") END
  291.     END Quick;
  292.     PROCEDURE Heap*;
  293.         VAR l, r: INTEGER; data: Data;
  294.         PROCEDURE Sift(l, r: INTEGER);
  295.             VAR i, j: INTEGER;
  296.         BEGIN i:=l; j:=2*l+1;
  297.             IF (j+1 < r) & Less(data, j, j+1) THEN INC(j) END;
  298.             WHILE (j < r) & ~Less(data, j, i) DO Swap(data, i, j); i:=j; j:=2*j+1;
  299.                 IF (j+1 < r) & Less(data, j, j+1) THEN INC(j) END
  300.             END
  301.         END Sift;
  302.     BEGIN data:=ParameterData();
  303.         IF data#NIL THEN Start; l:=N DIV 2; r:=N;
  304.             WHILE l > 0 DO DEC(l); Sift(l, r) END;
  305.             WHILE r > 0 DO DEC(r); Swap(data, 0, r); Sift(0, r) END;
  306.             Stop("SortDemo.Heap")
  307.         END
  308.     END Heap;
  309.     PROCEDURE Smooth*;
  310.         VAR q, r, p, b, c: INTEGER; data: Data;
  311.         PROCEDURE Up(VAR b, c: INTEGER);
  312.             VAR b1: INTEGER;
  313.         BEGIN b1:=b; b:=b+c+1; c:=b1
  314.         END Up;
  315.         PROCEDURE Down(VAR b, c: INTEGER);
  316.             VAR c1: INTEGER;
  317.         BEGIN c1:=c; c:=b-c-1; b:=c1
  318.         END Down;
  319.         PROCEDURE Sift(r, b, c: INTEGER);
  320.             VAR r1: INTEGER;
  321.         BEGIN
  322.             WHILE b >= 3 DO r1:=r-b+c;
  323.                 IF Less(data, r1, r-1) THEN r1:=r-1; Down(b, c) END;
  324.                 IF Less(data, r, r1) THEN Swap(data, r, r1); r:=r1; Down(b, c)
  325.                 ELSE b:=1
  326.                 END
  327.             END
  328.         END Sift;
  329.         PROCEDURE Trinkle(r, p, b, c: INTEGER);
  330.             VAR r1, r2: INTEGER;
  331.         BEGIN
  332.             WHILE p > 0 DO
  333.                 WHILE ~ODD(p) DO p:=p DIV 2; Up(b, c) END;
  334.                 r2:=r-b;
  335.                 IF (p=1) OR ~Less(data, r, r2) THEN p:=0
  336.                 ELSE p:=p-1;
  337.                     IF b=1 THEN Swap(data, r, r2); r:=r2
  338.                     ELSE r1:=r-b+c;
  339.                         IF Less(data, r1, r-1) THEN r1:=r-1; Down(b, c); p:=p*2 END;
  340.                         IF ~Less(data, r2, r1) THEN Swap(data, r, r2); r:=r2
  341.                         ELSE Swap(data, r, r1); r:=r1; Down(b, c); p:=0
  342.                         END
  343.                     END
  344.                 END
  345.             END;
  346.             Sift(r, b, c)
  347.         END Trinkle;
  348.         PROCEDURE SemiTrinkle(r, p, b, c: INTEGER);
  349.             VAR r1: INTEGER;
  350.         BEGIN r1:=r-c;
  351.             IF Less(data, r, r1) THEN Swap(data, r, r1); Trinkle(r1, p, b, c) END
  352.         END SemiTrinkle;
  353.     BEGIN data:=ParameterData();
  354.         IF data#NIL THEN Start; q:=1; r:=0; p:=1; b:=1; c:=1;
  355.             WHILE q#N DO
  356.                 IF p MOD 8=3 (* p=... 011 *) THEN Sift(r, b, c);
  357.                     p:=(p+1) DIV 4; Up(b, c); Up(b, c) (* b >= 3 *)
  358.                 ELSE (* p=... 01 *)
  359.                     IF (q+c) < N THEN Sift(r, b, c) ELSE Trinkle(r, p, b, c) END;
  360.                     Down(b, c); p:=p*2;
  361.                     WHILE b#1 DO Down(b, c); p:=p*2 END;
  362.                     p:=p+1
  363.                 END;
  364.                 q:=q+1; r:=r+1 
  365.             END;
  366.             Trinkle(r, p, b, c);
  367.             WHILE q#1 DO q:=q-1; p:=p-1;
  368.                 IF b=1 THEN r:=r-1;
  369.                     WHILE ~ODD(p) DO p:=p DIV 2; Up(b, c) END
  370.                 ELSE (* b >= 3 *) r:=r-b+c;
  371.                     IF p > 0 THEN SemiTrinkle(r, p, b, c) END;
  372.                     Down(b, c); p:=p*2+1; r:=r+c;
  373.                     SemiTrinkle(r, p, b, c); Down(b, c); p:=p*2+1
  374.                 END
  375.             END;
  376.             Stop("SortDemo.Smooth")
  377.         END
  378.     END Smooth;
  379. BEGIN seed:=Oberon.Time(); Texts.OpenWriter(w)
  380. END SortDemo.
  381.